home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / graphics / gip_02.zip / VIEWGIP.BAS < prev    next >
BASIC Source File  |  1994-12-18  |  21KB  |  788 lines
  1. '
  2. ' ViewGIP r.02
  3. ' John David Rohner, Milwaukee, WI
  4. ' December 1994
  5. '
  6. ' Copyright (c) 1994, John Rohner.  All rights reserved.
  7. '
  8. 'Release History
  9. '
  10. ' .01 Iniital release.
  11. ' .02 Now handles wildcards, and .ICO for the input filename.  Providing the
  12. '     useful: VIEWGIP *.ICO or VIEWGIP *.GIP, etc.
  13. '     Dropped the CGA use-top-4-colors adjusting code for .ICO viewing.
  14. '     Added whatever BMP code I could come up with.
  15. '     286 or better now required.
  16. '
  17. DEFINT A-Z
  18. '
  19. ' Some constants and data types (from JDR_BBS).
  20. '
  21. TYPE FileInfo                    'Len = 29
  22.   FName AS STRING * 12           'File name.
  23.   FSize AS LONG                  'File Size in bytes.
  24.   FDate AS STRING * 9            'File date (sometimes).
  25. END TYPE
  26. '
  27. ' General subroutine library (from JDR_BBS).
  28. '
  29. DECLARE SUB      Ansi (Inpt$)
  30. DECLARE FUNCTION AscMid% (Inpt$, BYVAL Start%)
  31. DECLARE FUNCTION BitsRol% (BYVAL Inpt%, BYVAL ShiftLeft%)
  32. DECLARE FUNCTION BitsRor% (BYVAL Inpt%, BYVAL ShiftRight%)
  33. DECLARE FUNCTION BitsShr% (BYVAL Inpt%, BYVAL ShiftRight%)
  34. DECLARE FUNCTION BitsShl% (BYVAL Inpt%, BYVAL ShiftRight%)
  35. DECLARE SUB      BitSet (Inpt%, BYVAL BitNum%)
  36. DECLARE SUB      ColorText (BYVAL Horiz%, BYVAL Vert%, BYVAL attr%, BYVAL char%)
  37. DECLARE SUB      CursorOff ()
  38. DECLARE SUB      CursorOn ()
  39. DECLARE SUB      Delay ()
  40. DECLARE FUNCTION FindF% (File$, Typ AS FileInfo)
  41. DECLARE SUB      FileClose (BYVAL Handle%)
  42. DECLARE SUB      FileGetSLoc (BYVAL Handle%, BYVAL Location&, Inpt$)
  43. DECLARE FUNCTION FileOpen% (FileName$,BYVAL attr%)
  44. DECLARE SUB      GLine (BYVAL CurrentH%, BYVAL CurrentV%, BYVAL TillH%, BYVAL TillV%, BYVAL Colr%, BYVAL GDither%)
  45. DECLARE SUB      GPixel (BYVAL Horiz%, BYVAL Vert%, BYVAL Colr%)
  46. DECLARE SUB      GPixel2 ()
  47. DECLARE SUB      GSetMode (BYVAL GMode%, BYVAL VGA1%, BYVAL VGA2%)
  48. DECLARE FUNCTION KBIn% ()
  49. DECLARE FUNCTION LongMid& (Inpt$, BYVAL Start%)
  50. DECLARE FUNCTION IntMid% (Inpt$, BYVAL Start%)
  51. DECLARE FUNCTION StrSrch1% (Inpt$, BYVAL Find%)
  52. DECLARE FUNCTION StrSrch2% (BYVAL Start%, Inpt$, BYVAL Find%)
  53. DECLARE FUNCTION StrSrchR% (Inpt$, BYVAL Ascii%)
  54.  
  55. declare sub delaytiny (byval i%)
  56. declare sub getpalette (a$)
  57. declare sub setpalette (a$)
  58.  
  59. declare sub DAMCSHLF (byval i0%, byval i1%, a$, byval i3%, byval i4%)
  60.  
  61. DECLARE SUB      FilePutSEnd (BYVAL Handle%, Inpt$)
  62.  
  63.  
  64. '
  65. ' Program specific subroutine library.
  66. '
  67. DECLARE SUB      DoGIPForBBS (p$,p)
  68. DECLARE SUB      FileCloseR (p)
  69. DECLARE FUNCTION FileOpenR% (p$)
  70. DECLARE SUB      GBox (p,p0,p1,p2,p3,p4)
  71. DECLARE SUB      GBoxFilled (p,p0,p1,p2,p3,p4)
  72. DECLARE SUB      GIPParse1 (p$,p0$,p)
  73. DECLARE SUB      GIPParse2 (p$,p0,p1,p2)
  74. DECLARE FUNCTION ParseForPath$ (p$)
  75. DECLARE SUB      ShowIcon2 (p$)
  76. DECLARE SUB      ShowBMP (p$)
  77. DECLARE FUNCTION Val4& (p$)
  78. '
  79. ' Global variables.
  80. '
  81. COMMON SHARED _
  82.   C1310$, Null$, Chars$(), FFile AS FileInfo, Buff$, _
  83.   GInUse, GHoriz, GVert, GColor, GPattern, GPatShift, GObjects$()
  84.  
  85.  
  86. '
  87. ' Actual program start.
  88. '
  89.  
  90.   REDIM Chars$(255)
  91.   FOR K = 0 TO 255
  92.     Chars$(K) = CHR$(K)
  93.   NEXT
  94.   C1310$ = Chars$(13) + Chars$(10)
  95.   CALL Ansi("ViewGIP     GIP-able file lister     release .02" + C1310$)
  96.   CALL Ansi("Copyright (C) John David Rohner 1993.  All rights reserved." + C1310$ + C1310$)
  97.   Null$ = ""
  98.   REDIM GObjects$(255)
  99.   K$ = UCASE$(RTRIM$(LTRIM$(Command$)))
  100.   K = FindF(K$,FFile)
  101.   IF K = 0 THEN K$ = K$ + ".GIP" : _
  102.                 K = FindF(K$,FFile)
  103.   IF K = 0 _
  104.      THEN CALL Ansi("1File not found.  Use ViewGIP <pathname>" + C1310$) : _
  105.           CALL Ansi("1Wildcards OK." + C1310$ + C1310$) : _
  106.           END
  107.   K3$ = K$
  108.   K3 = 0
  109.   K$ = ParseForPath$(K$)
  110.   DO
  111.     K3 = K3 + 1
  112.     GInUse = 0
  113.     GHoriz = 1
  114.     GVert  = 1
  115.     GColor = 1
  116.     GPattern = -1
  117.     GPatShift = 0
  118.     SELECT CASE RIGHT$(RTRIM$(FFile.FName),4)
  119.       CASE ".ICO" : CALL GSetMode(2,0,0)
  120.                     CALL ShowIcon2(K$ + FFile.FName)
  121.       CASE ".BMP" : CALL GSetMode(2,0,0)
  122.                     CALL ShowBMP(K$ + FFile.FName)
  123.       CASE ELSE
  124.            Buff$ = SPACE$(FFile.FSize)
  125.            K = FileOpenR(K$ + FFile.FName)
  126.            CALL FileGetSLoc(K,0&,Buff$)
  127.            CALL FileCloseR(K)
  128.            CALL DoOutput
  129.     END SELECT
  130.     DO : K = KBIn
  131.     LOOP UNTIL K > 0
  132.     SELECT CASE K
  133.       CASE IS > 18000
  134.            K = -2
  135.            DO
  136.              IF K < 0 _
  137.                 THEN K0 = GHoriz : _
  138.                      K1 = GVert : _
  139.                      Buff$ = "C14;G104,176,0;H =" + STR$(GHoriz) + "G176,176,0;V =" + STR$(GVert) : _
  140.                      Buff$ = "P0,0;C0;G135,175,0;F24,8,0;G207,175,0;F24,8,0;" + Buff$ : _
  141.                      CALL DoOutput : _
  142.                      GHoriz = K0 : _
  143.                      GVert = K1 : _
  144.                      CALL GPixel(GHoriz,GVert,14)
  145.              K = KBIn
  146.              SELECT CASE K
  147.                CASE 18432 : GVert = GVert - 1
  148.                             K = -1
  149.                CASE 20480 : GVert = GVert + 1
  150.                             K = -1
  151.                CASE 19200 : GHoriz = GHoriz - 1
  152.                             K = -1
  153.                CASE 19712 : GHoriz = GHoriz + 1
  154.                             K = -1
  155.                CASE 20736 : GVert = GVert + 1
  156.                             GHoriz = GHoriz + 1
  157.                             K = -1
  158.                CASE 18688 : GVert = GVert - 1
  159.                             GHoriz = GHoriz + 1
  160.                             K = -1
  161.                CASE 18176 : GVert = GVert - 1
  162.                             GHoriz = GHoriz - 1
  163.                             K = -1
  164.                CASE 20224 : GVert = GVert + 1
  165.                             GHoriz = GHoriz - 1
  166.                             K = -1
  167.              END SELECT
  168.            LOOP UNTIL K > 0
  169.     END SELECT
  170.     CALL GSetMode(0,0,0)
  171.     CALL CursorOn
  172.     K4 = 0
  173.     K = FindF(K3$,FFile)
  174.     DO
  175.       K5 = FindF(Null$,FFile)
  176.       K4 = K4 + 1
  177.     LOOP UNTIL K4 = K3
  178.   LOOP UNTIL K5 = 0
  179.  
  180. END
  181.  
  182.  
  183. SUB DoOutput
  184.  
  185.   WHILE LEN(Buff$) > 0
  186.     K = ASC(Buff$)
  187.     SELECT CASE K
  188.       CASE 19
  189.            K = 1
  190.            CALL DoGIPForBBS(Buff$,K)
  191.            Buff$ = MID$(Buff$,K)
  192.       CASE ELSE
  193.            SELECT CASE GInUse
  194.              CASE 0
  195.                   SELECT CASE K
  196.                     CASE 27
  197.                          K$ = Null$
  198.                          DO
  199.                            K0 = ASC(Buff$)
  200.                            K$ = K$ + Chars$(K0)
  201.                            Buff$ = MID$(Buff$,2)
  202.                          LOOP UNTIL StrSrch1("fmCsuJKHABDR",K0) > 0 OR LEN(Buff$) = 0
  203.                          CALL Ansi(K$)
  204.                     CASE ELSE
  205.                          CALL Ansi(Chars$(K))
  206.                          Buff$ = MID$(Buff$,2)
  207.                   END SELECT
  208.              CASE ELSE
  209.                   IF K = 13 THEN GHoriz = 0 : _
  210.                                  GVert = GVert + 8 : _
  211.                                  K = -1
  212.                   IF K = 10 THEN K = -1
  213.                   IF K >= 0 THEN CALL ColorText(GHoriz,GVert,GColor,K) : _
  214.                                  GHoriz = GHoriz + 8
  215.                   Buff$ = MID$(Buff$,2)
  216.            END SELECT
  217.     END SELECT
  218.   WEND
  219.  
  220. END SUB
  221.  
  222.  
  223.  
  224.  
  225. '
  226. ' General program routines.
  227. '
  228.  
  229.  
  230.  
  231.         '* * * * * *
  232.         ' This routine will open a file in read-only, and read/write
  233.         ' share mode.
  234.         '
  235.         ' p$  pathname of the file to open.
  236.         '
  237.         ' Date last checked for perfection: Oct 21 1993
  238.         '
  239. FUNCTION FileOpenR% (p$)
  240.  
  241.   K = FileOpen(p$,128)
  242.   IF K = -1 THEN TT$ = C1310$ + C1310$ + _
  243.                        "File error, unable to open " + _
  244.                        p$ + "" + C1310$ + C1310$ : _
  245.                  CALL Ansi(TT$) : _
  246.                  SYSTEM
  247.   FileOpenR% = K
  248.  
  249. END FUNCTION
  250.         '
  251.         '* * * *
  252.  
  253.  
  254.  
  255.         '* * * * * *
  256.         ' This routine will close a file opened with FileOpenR.
  257.         '
  258.         ' p  handle of already-opened file.
  259.         '
  260.         ' Date last checked for perfection: Oct 21 1993
  261.         '
  262. SUB FileCloseR (p)
  263.  
  264.   CALL FileClose(p)
  265.  
  266. END SUB
  267.         '
  268.         '* * * *
  269.  
  270.  
  271.  
  272.         '* * * * * *
  273.         ' This routine will convert a string to a number.
  274.         '
  275.         ' p$  is the number in string form to use.
  276.         '
  277.         ' This routine returns the value as seen from the opposite
  278.         ' end, and stops when it reaches the first backwards
  279.         ' non-number.  Under VAL() '123xyz' = 123, here it = 0.  Under
  280.         ' VAL() 'xyz123' = 0, here it equals 123.
  281.         '
  282.         ' Found no use for negatives.  So, the negative symbol will be
  283.         ' just another 'nonnumeric stop flag'.
  284.         '
  285.         ' Trailing spaces are ignored.
  286.         '
  287.         ' Leading spaces and zero's are ignored.  Although '  xx yy'
  288.         ' will still only return yy, as the space between two numbers
  289.         ' is a stopper.
  290.         '
  291.         ' It only works with integers, thus sending '101.50' will
  292.         ' return 50.
  293.         '
  294.         ' For numbers greater than 1,xxx,xxx,xxx we stop at the "1"
  295.         ' position.
  296.         '
  297.         ' Date last checked for perfection: Oct 15 1993
  298.         '
  299. FUNCTION Val4& (p$)
  300.  
  301.   k& = 0
  302.   k0& = 1
  303.   K = LEN(RTRIM$(p$))
  304.   SELECT CASE K
  305.     CASE IS > 15
  306.          K3 = 0
  307.          FOR K0 = 0 TO 15
  308.            K1 = AscMid(p$,K - K0) - 48
  309.            IF K1 = 1 THEN CALL BitSet(K3,K0 + 1) _
  310.                      ELSE IF K1 <> 0 THEN EXIT FOR
  311.          NEXT
  312.          IF K0 = 16 THEN K = -1 : _
  313.                          K& = K3
  314.   END SELECT
  315.   K1 = 0
  316.   SELECT CASE K
  317.     CASE IS > 0
  318.          DO
  319.            K0 = AscMid(p$,K) - 48
  320.            K1 = K1 + 1
  321.            IF (K0 < 0) OR (K0 > 9) OR (K1 = 11) OR (K1 = 10 AND K0 > 1) _
  322.               THEN EXIT DO
  323.            k& = k& + k0& * K0
  324.            k0& = 10 * k0&
  325.            K = K - 1
  326.          LOOP UNTIL K = 0
  327.          IF K > 0 THEN IF AscMid(p$,K) = 45 THEN K& = - K&
  328.   END SELECT
  329.   Val4& = k&
  330.  
  331. END FUNCTION
  332.         '
  333.         '* * * *
  334.  
  335.  
  336.  
  337.  
  338. '
  339. ' GIP routines.
  340. '
  341.  
  342.  
  343.  
  344.         '* * * * * *
  345.         ' This routine will process a GIP string.
  346.         '
  347.         ' p$  string containing GIP code (can be the full string, not just
  348.         '     the short GIP-only segment).
  349.         '
  350.         ' p  offset in p$ working on now, p is updated upon exit.
  351.         '
  352.         ' Date last checked for perfection: Dec 7 1993
  353.         '
  354. SUB DoGIPForBBS (p$,p)
  355.  
  356.   K = p
  357.   CALL GIPParse1(p$,K$,p)
  358.   K1 = GHoriz
  359.   K2 = GVert
  360.   K = AscMid(p$,K + 1)
  361.   IF GInUse < 0 THEN K = 0
  362.   IF LEN(K$) = 0 THEN K = 0
  363.   SELECT CASE K
  364.     CASE 83
  365.          '
  366.          ' Sn;      switch to screen mode n.
  367.          '
  368.          GHoriz = 0
  369.          GVert  = 0
  370.          GColor = 15
  371.          GPattern = -1
  372.          GPatShift = 0
  373.          GInUse = 0
  374.          K = Val4&(K$)
  375.          IF K < 256 THEN GInUse = K
  376.          CALL GSetMode(GInUse,0,0)
  377.          CALL CursorOff
  378.     CASE 67
  379.          '
  380.          ' Cn;      switch to color n.
  381.          '
  382.          K = Val4&(K$)
  383.          IF K < 256 THEN GColor = K
  384.     CASE 71
  385.          '
  386.          ' Gh,v,d;  go to to screen point h,v,d.
  387.          '
  388.          CALL GipParse2(K$,GHoriz,GVert,0)
  389.     CASE 77
  390.          '
  391.          ' Mh,v,d;  go to to offset point h,v,d.
  392.          '
  393.          CALL GipParse2(K$,GHoriz,GVert,0)
  394.          GHoriz = K1 + GHoriz
  395.          GVert  = K2 + GVert
  396.     CASE 76
  397.          '
  398.          ' Lh,v,d;  draw a line to offset h,v,d.
  399.          '
  400.          CALL GipParse2(K$,GHoriz,GVert,0)
  401.          GHoriz = K1 + GHoriz
  402.          GVert  = K2 + GVert
  403.          IF GInUse > 0 THEN CALL GLine(K1,K2,GHoriz,GVert,GColor,GPattern)
  404.     CASE 66
  405.          '
  406.          ' Bh,v,d;  draw a rectangle to offset corner h,v,d.
  407.          '
  408.          CALL GipParse2(K$,K1,K2,0)
  409.          IF GInUse > 0 _
  410.             THEN CALL GBox(GHoriz,GVert,GHoriz + K1,GVert + K2,GColor,GPattern)
  411.     CASE 70
  412.          '
  413.          ' Fh,v,d;  draw a filled/solid rectangle to offset corner h,v,d.
  414.          '
  415.          CALL GipParse2(K$,K1,K2,0)
  416.          IF GInUse > 0 _
  417.             THEN CALL GBoxFilled(GHoriz,GVert,GHoriz + K1,GVert + K2,GColor,GPattern)
  418.     CASE 102
  419.          '
  420.          ' fpathname;  send a file.
  421.          '
  422.          K$ = UCASE$(K$)
  423.          SELECT CASE FindF(K$,FFile)
  424.            CASE IS <> 0
  425.                 SELECT CASE RIGHT$(K$,4)
  426.                   CASE ".ICO" : CALL ShowIcon2(K$)
  427.                   CASE ".BMP" : CALL ShowBMP(K$)
  428.                   CASE ELSE
  429.                        CALL GSetMode(0,0,0)
  430.                        K = FileOpenR(K$)
  431.                        TT$ = " "
  432.                        FOR K& = 0 TO FFile.FSize
  433.                          CALL FileGetSLoc(K,K&,TT$)
  434.                          CALL Ansi(TT$)
  435.                        NEXT
  436.                        CALL FileCloseR(K)
  437.                 END SELECT
  438.          END SELECT
  439.     CASE 80
  440.          '
  441.          ' Pn;      switch to pattern n.
  442.          '
  443.          CALL GipParse2(K$,GPattern,0,GPatShift)
  444.          IF GPattern = 0 THEN GPattern = -1
  445.     CASE 79
  446.          '
  447.          ' On;~xxx~    define Object number n.
  448.          '
  449.          K = Val4&(K$)
  450.          SELECT CASE K
  451.            CASE 1 TO 255
  452.                 GObjects$(K) = Null$
  453.                 SELECT CASE AscMid(p$,p)
  454.                   CASE 126
  455.                        p = p + 1
  456.                        K0 = AscMid(p$,p)
  457.                        WHILE K0 <> 126
  458.                          GObjects$(K) = GObjects$(K) + Chars$(K0)
  459.                          p = p + 1
  460.                          K0 = AscMid(p$,p)
  461.                        WEND
  462.                        p = p + 1
  463.                 END SELECT
  464.          END SELECT
  465.     CASE 111
  466.          '
  467.          ' On;      display Object number n.
  468.          '
  469.          K = Val4&(K$)
  470.          SELECT CASE K
  471.            CASE 1 TO 255
  472.                 p$ = LEFT$(p$,p - 1) + GObjects$(K) + MID$(p$,p)
  473.          END SELECT
  474.   END SELECT
  475.  
  476. END SUB
  477.         '
  478.         '* * * *
  479.  
  480.  
  481.  
  482.         '* * * * * *
  483.         ' This routine will parse a section of string, pulling out the
  484.         ' GIP string.
  485.         '
  486.         ' p$  string to process.
  487.         '
  488.         ' p0$ GIP string (excluding leading ASCII 19 and trailing ";").
  489.         '
  490.         ' p   upon entry it points to the ASCII 19, upon return it points
  491.         '     to the semi-colon.
  492.         '
  493.         ' Date last checked for perfection: Dec 7 1993
  494.         '
  495. SUB GIPParse1 (p$,p0$,p)
  496.  
  497.   K = StrSrch2(p,p$,59)
  498.   IF K > 0 AND LEN(p$) > 2 THEN p0$ = MID$(p$,p + 2,K - p - 2) _
  499.                            ELSE p0$ = Null$
  500.   p = K + 1
  501.  
  502. END SUB
  503.         '
  504.         '* * * *
  505.  
  506.  
  507.  
  508.         '* * * * * *
  509.         ' This routine will parses a 3-D GIP string for its three
  510.         ' coordinates.
  511.         '
  512.         ' p$  string to process.
  513.         '
  514.         ' p0  returns with the "h" (first) coordinate.
  515.         '
  516.         ' p1  returns with the "v" (second) coordinate.
  517.         '
  518.         ' p2  returns with the "d" (third) coordinate.
  519.         '
  520.         ' Date last checked for perfection: Dec 7 1993
  521.         '
  522. SUB GIPParse2 (p$,p0,p1,p2)
  523.  
  524.   p0 = StrSrch1(p$,44)
  525.   p1 = StrSrch2(p0,p$,44)
  526.   IF p0 > 0 THEN p0 = Val4&(LEFT$(p$,p0 - 1))
  527.   IF p1 > 0 THEN p1 = Val4&(LEFT$(p$,p1 - 1))
  528.   p2 = Val4&(p$)
  529.  
  530. END SUB
  531.         '
  532.         '* * * *
  533.  
  534.  
  535.  
  536.         '* * * * * *
  537.         ' This routine will display an empty rectangle.
  538.         '
  539.         ' p   starting h coordinate.
  540.         '
  541.         ' p0  starting v coordinate.
  542.         '
  543.         ' p1  ending h coordinate.
  544.         '
  545.         ' p2  ending v coordinate.
  546.         '
  547.         ' p3  color to use.
  548.         '
  549.         ' p4  pattern to use.
  550.         '
  551.         ' Date last checked for perfection: Oct 22 1993
  552.         '
  553. SUB GBox (p,p0,p1,p2,p3,p4)
  554.  
  555.   CALL GLine(p,p0,p1,p0,p3,p4)
  556.   CALL GLine(p1,p0,p1,p2,p3,p4)
  557.   CALL GLine(p1,p2,p,p2,p3,p4)
  558.   CALL GLine(p,p2,p,p0,p3,p4)
  559.  
  560. END SUB
  561.         '
  562.         '* * * *
  563.  
  564.  
  565.  
  566.         '* * * * * *
  567.         ' This routine will display a filled rectangle.
  568.         '
  569.         ' p   starting h coordinate.
  570.         '
  571.         ' p0  starting v coordinate.
  572.         '
  573.         ' p1  ending h coordinate.
  574.         '
  575.         ' p2  ending v coordinate.
  576.         '
  577.         ' p3  color to use.
  578.         '
  579.         ' p4  pattern to use (updated upon return).
  580.         '
  581.         ' The pattern is rotated left after each line.
  582.         '
  583.         ' Date last checked for perfection: Oct 22 1993
  584.         '
  585. SUB GBoxFilled(p,p0,p1,p2,p3,p4)
  586.  
  587.   SELECT CASE p0
  588.     CASE IS <= p2
  589.          FOR K = p0 TO p2
  590.            CALL GLine(p,K,p1,K,p3,p4)
  591.            IF GPatShift < 0 _
  592.               THEN p4 = BitsROL(p4,- GPatShift) _
  593.               ELSE IF GPatShift > 0 THEN p4 = BitsROR(p4,GPatShift)
  594.          NEXT
  595.     CASE ELSE
  596.          FOR K = p0 TO p2 STEP -1
  597.            CALL GLine(p,K,p1,K,p3,p4)
  598.            IF GPatShift < 0 _
  599.               THEN p4 = BitsROL(p4,- GPatShift) _
  600.               ELSE IF GPatShift > 0 THEN p4 = BitsROR(p4,GPatShift)
  601.          NEXT
  602.   END SELECT
  603.  
  604. END SUB
  605.         '
  606.         '* * * *
  607.  
  608.  
  609.  
  610.         '* * * * * *
  611.         ' This routine will display an icon.
  612.         '
  613.         ' p$  pathname of file to use.
  614.         '
  615.         ' It has a nice, and unecessary, processor to display the icons
  616.         ' in CGA mode.
  617.         '
  618.         ' Date last checked for perfection: Oct 22 1993
  619.         '
  620. SUB ShowIcon2 (p$)
  621.  
  622.   K$ = SPACE$(16)
  623.   K = FileOpenR(p$)
  624.   CALL FileGetSLoc(K,6,K$)
  625.   K0 = ASC(K$)
  626.   K1 = AscMid(K$,2)
  627.   K2 = AscMid(K$,3)
  628.   K3 = LongMid&(K$,9)
  629.   K& = LongMid&(K$,13)
  630.  
  631.   K$ = SPACE$((K1 \ 2) * K0)
  632.   CALL FileGetSLoc(K,K& + 104,K$)
  633.   CALL FileCloseR(K)
  634.   CALL DAMCSHLF(GHoriz,GVert + K0,K$,K1 \ 2,4)
  635.  
  636. END SUB
  637.         '
  638.         '* * * *
  639.  
  640.  
  641.  
  642.  
  643. 'quick and dirty BMP viewer--trouble with the colors right now.
  644. '
  645. 'also modify it to put the image at the current coordinates (and returing
  646. 'at those same coordiates).
  647. SUB ShowBMP (p$)
  648.  
  649.   CALL DoBMP(p$,aa$)
  650.  
  651. 'x$ = space$(51)
  652. x$ = space$(48)
  653. call getpalette(x$)
  654. 'x$ = mid$(x$,4)
  655. k = fileopen("pal.out",130)
  656. call fileputsend(k,x$)
  657. call fileclose(k)
  658. y$ = x$
  659. for a = 1 to len(aa$)
  660.   mid$(aa$,a,1) = CHR$(BitsShr(ASC(MID$(aa$,a,1)),2))
  661. next
  662. k = fileopen("pal2.out",130)
  663. call fileputsend(k,aa$)
  664. call fileclose(k)
  665. call setpalette(aa$)
  666. 'x = -1
  667. 'do
  668. '  z$ = inkey$
  669. '  select case z$
  670. '    case "-"
  671. '         x = x - 1
  672. '         if x < 0 then x = 0
  673. '         for a = 1 to 48
  674. '           mid$(x$,a,1) = mid$(aa$,x + a,1)
  675. '         next
  676. '         call setpalette(x$)
  677. '    case "+"
  678. '         x = x + 1
  679. '         for a = 1 to 48
  680. '           mid$(x$,a,1) = mid$(aa$,x + a,1)
  681. '         next
  682. '         call setpalette(x$)
  683. '    CASE "1" : y$ = MID$(y$,2)
  684. '               x$ = y$
  685. '         call setpalette(x$)
  686. '         x = 0
  687. '  end select
  688. 'loop until z$ = "q" or z$ = "Q"
  689. while inkey$ = "" : WEND
  690. 'x$ = space$(51)
  691. x$ = space$(48)
  692. call getpalette(x$)
  693. 'x$ = mid$(x$,4)
  694. k = fileopen("pal.out",130)
  695. call fileputsend(k,x$)
  696. call fileclose(k)
  697. call setpalette(y$)
  698.  
  699. END SUB
  700.  
  701.  
  702.  
  703. '
  704. ' to compile: BC VIEWGIP.BAS /O/S/FS/G2;
  705. ' to link   : LINK /EXEPACK /PACKCODE VIEWGIP,,,ASSEMBLY\JDRBBS,,
  706. ' requires  : BC.EXE, LINK.EXE, BCL70EFR.LIB, BRT70EFR.LIB, and JDRBBS.LIB
  707. '             (Basic PDS 7.0+, and Juggernaut's assembly library)
  708. '
  709.  
  710.  
  711.  
  712.         '* * * * * *
  713.         ' Parse a pathname for the path.
  714.         '
  715.         ' p$ pathname to work with.
  716.         '
  717.         ' returns with the path (uppercased, with trailing '\').
  718.         '
  719.         ' Date last checked for perfection: May 3 1993
  720.         '
  721. FUNCTION ParseForPath$ (p$)
  722.  
  723.   K = StrSrchR(p$,92)
  724.   IF K = 0 THEN K = StrSrchR(p$,47)
  725.   ParseForPath$ = UCASE$(LEFT$(p$,K))
  726.  
  727. END FUNCTION
  728.         '
  729.         '* * * *
  730.  
  731. SUB DoBMP (p$,aa$)
  732.  
  733.   K = FileOpenR(p$)
  734. zz$ = space$(27)
  735. call filegetsloc(k,2&,zz$)
  736.  
  737. k1& = longmid(zz$,1)      'end of image
  738. k& = longmid(zz$,9)       'start of image
  739. kx1 = intmid(zz$,17)      'horizontal width
  740. kx2 = intmid(zz$,21)      'vertical height
  741. kz = ascmid(zz$,27)       'number of pixels per color
  742. ab$ = space$(64)          '16 * 3 \ 2
  743. call filegetsloc(k,54&,ab$)
  744. aa$ = Null$
  745. for a = 1 to 16
  746.   aa$ = aa$ + MID$(ab$,(a - 1) * 4 + 1,3)
  747. next
  748. for a = 1 to 16 step 2
  749.   a$ = mid$(aa$,(a - 1) * 3 + 1,1)
  750.   b$ = mid$(aa$,(a - 1) * 3 + 3,1)
  751.   mid$(aa$,(a - 1) * 3 + 1,1) = b$
  752.   mid$(aa$,(a - 1) * 3 + 3,1) = a$
  753. next
  754.   ghoriz = 0
  755.   aa = kx2
  756.   if kz = 8 then xx = kx1 _
  757.             else xx = kx1 \ 2
  758. xy = (16384 \ xx) * xx
  759. x$ = space$(xy)
  760.          do
  761.            if (k1& - k&) < xy then x$ = left$(x$,k1& - k&)
  762.            CALL FileGetSLoc(K,k&,x$)
  763. 'select case zz3
  764. '  case 1  : zz3 = 4
  765. '  case 2  : zz3 = 2
  766. '  case 3  : zz3 = 6
  767. '  case 4  : zz3 = 1
  768. '  case 5  : zz3 = 5
  769. '  case 6  : zz3 = 3
  770. '  case 7  : zz3 = 8
  771. '  case 8  : zz3 = 7
  772. '  case 9  : zz3 = 12
  773. '  case 10 : zz3 = 10
  774. '  case 11 : zz3 = 14
  775. '  case 12 : zz3 = 9
  776. '  case 13 : zz3 = 13
  777. '  case 14 : zz3 = 11
  778. 'end select
  779.            call DAMCSHLF(GHoriz,aa,x$,xx,kz)
  780.            k& = k& + xy
  781.            aa = aa - (xy \ xx)
  782.          loop until k& >= k1&
  783.   CALL FileCloseR(K)
  784.  
  785. END SUB
  786.  
  787.  
  788.